home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / FROMUTS / XLISP1 / !XLisp / c / XLLIST < prev    next >
Text File  |  1990-02-23  |  19KB  |  842 lines
  1. /* xllist - xlisp built-in list functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. #ifdef MEGAMAX
  9. overlay "overflow"
  10. #endif
  11.  
  12. /* external variables */
  13. extern NODE ***xlstack;
  14. extern NODE *s_unbound;
  15. extern NODE *true;
  16.  
  17. /* external routines */
  18. extern int eq(),eql(),equal();
  19.  
  20. /* forward declarations */
  21. FORWARD NODE *cxr();
  22. FORWARD NODE *nth(),*assoc();
  23. FORWARD NODE *subst(),*sublis(),*map();
  24. FORWARD NODE *cequal();
  25.  
  26. /* cxr functions */
  27. NODE *xcar(args) NODE *args; { return (cxr(args,"a")); }
  28. NODE *xcdr(args) NODE *args; { return (cxr(args,"d")); }
  29.  
  30. /* cxxr functions */
  31. NODE *xcaar(args) NODE *args; { return (cxr(args,"aa")); }
  32. NODE *xcadr(args) NODE *args; { return (cxr(args,"da")); }
  33. NODE *xcdar(args) NODE *args; { return (cxr(args,"ad")); }
  34. NODE *xcddr(args) NODE *args; { return (cxr(args,"dd")); }
  35.  
  36. /* cxxxr functions */
  37. NODE *xcaaar(args) NODE *args; { return (cxr(args,"aaa")); }
  38. NODE *xcaadr(args) NODE *args; { return (cxr(args,"daa")); }
  39. NODE *xcadar(args) NODE *args; { return (cxr(args,"ada")); }
  40. NODE *xcaddr(args) NODE *args; { return (cxr(args,"dda")); }
  41. NODE *xcdaar(args) NODE *args; { return (cxr(args,"aad")); }
  42. NODE *xcdadr(args) NODE *args; { return (cxr(args,"dad")); }
  43. NODE *xcddar(args) NODE *args; { return (cxr(args,"add")); }
  44. NODE *xcdddr(args) NODE *args; { return (cxr(args,"ddd")); }
  45.  
  46. /* cxxxxr functions */
  47. NODE *xcaaaar(args) NODE *args; { return (cxr(args,"aaaa")); }
  48. NODE *xcaaadr(args) NODE *args; { return (cxr(args,"daaa")); }
  49. NODE *xcaadar(args) NODE *args; { return (cxr(args,"adaa")); }
  50. NODE *xcaaddr(args) NODE *args; { return (cxr(args,"ddaa")); }
  51. NODE *xcadaar(args) NODE *args; { return (cxr(args,"aada")); }
  52. NODE *xcadadr(args) NODE *args; { return (cxr(args,"dada")); }
  53. NODE *xcaddar(args) NODE *args; { return (cxr(args,"adda")); }
  54. NODE *xcadddr(args) NODE *args; { return (cxr(args,"ddda")); }
  55. NODE *xcdaaar(args) NODE *args; { return (cxr(args,"aaad")); }
  56. NODE *xcdaadr(args) NODE *args; { return (cxr(args,"daad")); }
  57. NODE *xcdadar(args) NODE *args; { return (cxr(args,"adad")); }
  58. NODE *xcdaddr(args) NODE *args; { return (cxr(args,"ddad")); }
  59. NODE *xcddaar(args) NODE *args; { return (cxr(args,"aadd")); }
  60. NODE *xcddadr(args) NODE *args; { return (cxr(args,"dadd")); }
  61. NODE *xcdddar(args) NODE *args; { return (cxr(args,"addd")); }
  62. NODE *xcddddr(args) NODE *args; { return (cxr(args,"dddd")); }
  63.  
  64. /* cxr - common car/cdr routine */
  65. LOCAL NODE *cxr(args,adstr)
  66.   NODE *args; char *adstr;
  67. {
  68.     NODE *list;
  69.  
  70.     /* get the list */
  71.     list = xlmatch(LIST,&args);
  72.     xllastarg(args);
  73.  
  74.     /* perform the car/cdr operations */
  75.     while (*adstr && consp(list))
  76.     list = (*adstr++ == 'a' ? car(list) : cdr(list));
  77.  
  78.     /* make sure the operation succeeded */
  79.     if (*adstr && list)
  80.     xlfail("bad argument");
  81.  
  82.     /* return the result */
  83.     return (list);
  84. }
  85.  
  86. /* xcons - construct a new list cell */
  87. NODE *xcons(args)
  88.   NODE *args;
  89. {
  90.     NODE *arg1,*arg2;
  91.  
  92.     /* get the two arguments */
  93.     arg1 = xlarg(&args);
  94.     arg2 = xlarg(&args);
  95.     xllastarg(args);
  96.  
  97.     /* construct a new list element */
  98.     return (cons(arg1,arg2));
  99. }
  100.  
  101. /* xlist - built a list of the arguments */
  102. NODE *xlist(args)
  103.   NODE *args;
  104. {
  105.     NODE ***oldstk,*arg,*list,*val,*last;
  106.     NODE *lptr = NIL;
  107.  
  108.     /* create a new stack frame */
  109.     oldstk = xlsave(&arg,&list,&val,(NODE **)NULL);
  110.  
  111.     /* initialize */
  112.     arg = args;
  113.  
  114.     /* evaluate and append each argument */
  115.     for (last = NIL; arg; last = lptr) {
  116.  
  117.     /* evaluate the next argument */
  118.     val = xlarg(&arg);
  119.  
  120.     /* append this argument to the end of the list */
  121.     lptr = consa(val);
  122.     if (last == NIL)
  123.         list = lptr;
  124.     else
  125.         rplacd(last,lptr);
  126.     }
  127.  
  128.     /* restore the previous stack frame */
  129.     xlstack = oldstk;
  130.  
  131.     /* return the list */
  132.     return (list);
  133. }
  134.  
  135. /* xappend - built-in function append */
  136. NODE *xappend(args)
  137.   NODE *args;
  138. {
  139.     NODE ***oldstk,*arg,*list,*last,*val,*lptr;
  140.  
  141.     /* create a new stack frame */
  142.     oldstk = xlsave(&arg,&list,&last,&val,(NODE **)NULL);
  143.  
  144.     /* initialize */
  145.     arg = args;
  146.  
  147.     /* evaluate and append each argument */
  148.     while (arg) {
  149.  
  150.     /* evaluate the next argument */
  151.     list = xlmatch(LIST,&arg);
  152.  
  153.     /* append each element of this list to the result list */
  154.     while (consp(list)) {
  155.  
  156.         /* append this element */
  157.         lptr = consa(car(list));
  158.         if (last == NIL)
  159.         val = lptr;
  160.         else
  161.         rplacd(last,lptr);
  162.  
  163.         /* save the new last element */
  164.         last = lptr;
  165.  
  166.         /* move to the next element */
  167.         list = cdr(list);
  168.     }
  169.     }
  170.  
  171.     /* restore previous stack frame */
  172.     xlstack = oldstk;
  173.  
  174.     /* return the list */
  175.     return (val);
  176. }
  177.  
  178. /* xreverse - built-in function reverse */
  179. NODE *xreverse(args)
  180.   NODE *args;
  181. {
  182.     NODE ***oldstk,*list,*val;
  183.  
  184.     /* create a new stack frame */
  185.     oldstk = xlsave(&list,&val,(NODE **)NULL);
  186.  
  187.     /* get the list to reverse */
  188.     list = xlmatch(LIST,&args);
  189.     xllastarg(args);
  190.  
  191.     /* append each element of this list to the result list */
  192.     while (consp(list)) {
  193.  
  194.     /* append this element */
  195.     val = cons(car(list),val);
  196.  
  197.     /* move to the next element */
  198.     list = cdr(list);
  199.     }
  200.  
  201.     /* restore previous stack frame */
  202.     xlstack = oldstk;
  203.  
  204.     /* return the list */
  205.     return (val);
  206. }
  207.  
  208. /* xlast - return the last cons of a list */
  209. NODE *xlast(args)
  210.   NODE *args;
  211. {
  212.     NODE *list;
  213.  
  214.     /* get the list */
  215.     list = xlmatch(LIST,&args);
  216.     xllastarg(args);
  217.  
  218.     /* find the last cons */
  219.     while (consp(list) && cdr(list))
  220.     list = cdr(list);
  221.  
  222.     /* return the last element */
  223.     return (list);
  224. }
  225.  
  226. /* xmember - built-in function 'member' */
  227. NODE *xmember(args)
  228.   NODE *args;
  229. {
  230.     NODE ***oldstk,*x,*list,*fcn,*val;
  231.     int tresult;
  232.  
  233.     /* create a new stack frame */
  234.     oldstk = xlsave(&x,&list,&fcn,(NODE **)NULL);
  235.  
  236.     /* get the expression to look for and the list */
  237.     x = xlarg(&args);
  238.     list = xlmatch(LIST,&args);
  239.     xltest(&fcn,&tresult,&args);
  240.     xllastarg(args);
  241.  
  242.     /* look for the expression */
  243.     for (val = NIL; consp(list); list = cdr(list))
  244.     if (dotest(x,car(list),fcn) == tresult) {
  245.         val = list;
  246.         break;
  247.     }
  248.  
  249.     /* restore the previous stack frame */
  250.     xlstack = oldstk;
  251.  
  252.     /* return the result */
  253.     return (val);
  254. }
  255.  
  256. /* xassoc - built-in function 'assoc' */
  257. NODE *xassoc(args)
  258.   NODE *args;
  259. {
  260.     NODE ***oldstk,*x,*alist,*fcn,*pair,*val;
  261.     int tresult;
  262.  
  263.     /* create a new stack frame */
  264.     oldstk = xlsave(&x,&alist,&fcn,(NODE **)NULL);
  265.  
  266.     /* get the expression to look for and the association list */
  267.     x = xlarg(&args);
  268.     alist = xlmatch(LIST,&args);
  269.     xltest(&fcn,&tresult,&args);
  270.     xllastarg(args);
  271.  
  272.     /* look for the expression */
  273.     for (val = NIL; consp(alist); alist = cdr(alist))
  274.     if ((pair = car(alist)) && consp(pair))
  275.         if (dotest(x,car(pair),fcn) == tresult) {
  276.         val = pair;
  277.         break;
  278.         }
  279.  
  280.     /* restore the previous stack frame */
  281.     xlstack = oldstk;
  282.  
  283.     /* return the result */
  284.     return (val);
  285. }
  286.  
  287. /* xsubst - substitute one expression for another */
  288. NODE *xsubst(args)
  289.   NODE *args;
  290. {
  291.     NODE ***oldstk,*to,*from,*expr,*fcn,*val;
  292.     int tresult;
  293.  
  294.     /* create a new stack frame */
  295.     oldstk = xlsave(&to,&from,&expr,&fcn,(NODE **)NULL);
  296.  
  297.     /* get the to value, the from value and the expression */
  298.     to = xlarg(&args);
  299.     from = xlarg(&args);
  300.     expr = xlarg(&args);
  301.     xltest(&fcn,&tresult,&args);
  302.     xllastarg(args);
  303.  
  304.     /* do the substitution */
  305.     val = subst(to,from,expr,fcn,tresult);
  306.  
  307.     /* restore the previous stack frame */
  308.     xlstack = oldstk;
  309.  
  310.     /* return the result */
  311.     return (val);
  312. }
  313.  
  314. /* subst - substitute one expression for another */
  315. LOCAL NODE *subst(to,from,expr,fcn,tresult)
  316.   NODE *to,*from,*expr,*fcn; int tresult;
  317. {
  318.     NODE ***oldstk,*carval,*cdrval,*val;
  319.  
  320.     if (dotest(expr,from,fcn) == tresult)
  321.     val = to;
  322.     else if (consp(expr)) {
  323.     oldstk = xlsave(&carval,&cdrval,(NODE **)NULL);
  324.     carval = subst(to,from,car(expr),fcn,tresult);
  325.     cdrval = subst(to,from,cdr(expr),fcn,tresult);
  326.     val = cons(carval,cdrval);
  327.     xlstack = oldstk;
  328.     }
  329.     else
  330.     val = expr;
  331.     return (val);
  332. }
  333.  
  334. /* xsublis - substitute using an association list */
  335. NODE *xsublis(args)
  336.   NODE *args;
  337. {
  338.     NODE ***oldstk,*alist,*expr,*fcn,*val;
  339.     int tresult;
  340.  
  341.     /* create a new stack frame */
  342.     oldstk = xlsave(&alist,&expr,&fcn,(NODE **)NULL);
  343.  
  344.     /* get the assocation list and the expression */
  345.     alist = xlmatch(LIST,&args);
  346.     expr = xlarg(&args);
  347.     xltest(&fcn,&tresult,&args);
  348.     xllastarg(args);
  349.  
  350.     /* do the substitution */
  351.     val = sublis(alist,expr,fcn,tresult);
  352.  
  353.     /* restore the previous stack frame */
  354.     xlstack = oldstk;
  355.  
  356.     /* return the result */
  357.     return (val);
  358. }
  359.  
  360. /* sublis - substitute using an association list */
  361. LOCAL NODE *sublis(alist,expr,fcn,tresult)
  362.   NODE *alist,*expr,*fcn; int tresult;
  363. {
  364.     NODE ***oldstk,*carval,*cdrval,*val;
  365.  
  366.     if (val = assoc(expr,alist,fcn,tresult))
  367.     val = cdr(val);
  368.     else if (consp(expr)) {
  369.     oldstk = xlsave(&carval,&cdrval,(NODE **)NULL);
  370.     carval = sublis(alist,car(expr),fcn,tresult);
  371.     cdrval = sublis(alist,cdr(expr),fcn,tresult);
  372.     val = cons(carval,cdrval);
  373.     xlstack = oldstk;
  374.     }
  375.     else
  376.     val = expr;
  377.     return (val);
  378. }
  379.  
  380. /* assoc - find a pair in an association list */
  381. LOCAL NODE *assoc(expr,alist,fcn,tresult)
  382.   NODE *expr,*alist,*fcn; int tresult;
  383. {
  384.     NODE *pair;
  385.  
  386.     for (; consp(alist); alist = cdr(alist))
  387.     if ((pair = car(alist)) && consp(pair))
  388.         if (dotest(expr,car(pair),fcn) == tresult)
  389.         return (pair);
  390.     return (NIL);
  391. }
  392.  
  393. /* xremove - built-in function 'remove' */
  394. NODE *xremove(args)
  395.   NODE *args;
  396. {
  397.     NODE ***oldstk,*x,*list,*fcn,*val,*p;
  398.     NODE *last = NIL;
  399.     int tresult;
  400.  
  401.     /* create a new stack frame */
  402.     oldstk = xlsave(&x,&list,&fcn,&val,(NODE **)NULL);
  403.  
  404.     /* get the expression to remove and the list */
  405.     x = xlarg(&args);
  406.     list = xlmatch(LIST,&args);
  407.     xltest(&fcn,&tresult,&args);
  408.     xllastarg(args);
  409.  
  410.     /* remove matches */
  411.     while (consp(list)) {
  412.  
  413.     /* check to see if this element should be deleted */
  414.     if (dotest(x,car(list),fcn) != tresult) {
  415.         p = consa(car(list));
  416.         if (val) rplacd(last,p);
  417.         else val = p;
  418.         last = p;
  419.     }
  420.  
  421.     /* move to the next element */
  422.     list = cdr(list);
  423.     }
  424.  
  425.     /* restore the previous stack frame */
  426.     xlstack = oldstk;
  427.  
  428.     /* return the updated list */
  429.     return (val);
  430. }
  431.  
  432. /* dotest - call a test function */
  433. int dotest(arg1,arg2,fcn)
  434.   NODE *arg1,*arg2,*fcn;
  435. {
  436.     NODE ***oldstk,*args,*val;
  437.  
  438.     /* create a new stack frame */
  439.     oldstk = xlsave(&args,(NODE **)NULL);
  440.  
  441.     /* build an argument list */
  442.     args = consa(arg1);
  443.     rplacd(args,consa(arg2));
  444.  
  445.     /* apply the test function */
  446.     val = xlapply(fcn,args);
  447.  
  448.     /* restore the previous stack frame */
  449.     xlstack = oldstk;
  450.  
  451.     /* return the result of the test */
  452.     return (val != NIL);
  453. }
  454.  
  455. /* xnth - return the nth element of a list */
  456. NODE *xnth(args)
  457.   NODE *args;
  458. {
  459.     return (nth(args,TRUE));
  460. }
  461.  
  462. /* xnthcdr - return the nth cdr of a list */
  463. NODE *xnthcdr(args)
  464.   NODE *args;
  465. {
  466.     return (nth(args,FALSE));
  467. }
  468.  
  469. /* nth - internal nth function */
  470. LOCAL NODE *nth(args,carflag)
  471.   NODE *args; int carflag;
  472. {
  473.     NODE *list;
  474.     int n;
  475.  
  476.     /* get n and the list */
  477.     if ((n = getfixnum(xlmatch(INT,&args))) < 0)
  478.     xlfail("bad argument");
  479.     if ((list = xlmatch(LIST,&args)) == NIL)
  480.     xlfail("bad argument");
  481.     xllastarg(args);
  482.  
  483.     /* find the nth element */
  484.     while (consp(list) && n--)
  485.     list = cdr(list);
  486.  
  487.     /* return the list beginning at the nth element */
  488.     return (carflag && consp(list) ? car(list) : list);
  489. }
  490.  
  491. /* xlength - return the length of a list or string */
  492. NODE *xlength(args)
  493.   NODE *args;
  494. {
  495.     NODE *arg;
  496.     int n;
  497.  
  498.     /* get the list or string */
  499.     arg = xlarg(&args);
  500.     xllastarg(args);
  501.  
  502.     /* find the length of a list */
  503.     if (listp(arg))
  504.     for (n = 0; consp(arg); n++)
  505.         arg = cdr(arg);
  506.  
  507.     /* find the length of a string */
  508.     else if (stringp(arg))
  509.     n = strlen(getstring(arg));
  510.  
  511.     /* find the length of a vector */
  512.     else if (vectorp(arg))
  513.     n = getsize(arg);
  514.  
  515.     /* otherwise, bad argument type */
  516.     else
  517.     xlerror("bad argument type",arg);
  518.  
  519.     /* return the length */
  520.     return (cvfixnum((FIXNUM)n));
  521. }
  522.  
  523. /* xmapc - built-in function 'mapc' */
  524. NODE *xmapc(args)
  525.   NODE *args;
  526. {
  527.     return (map(args,TRUE,FALSE));
  528. }
  529.  
  530. /* xmapcar - built-in function 'mapcar' */
  531. NODE *xmapcar(args)
  532.   NODE *args;
  533. {
  534.     return (map(args,TRUE,TRUE));
  535. }
  536.  
  537. /* xmapl - built-in function 'mapl' */
  538. NODE *xmapl(args)
  539.   NODE *args;
  540. {
  541.     return (map(args,FALSE,FALSE));
  542. }
  543.  
  544. /* xmaplist - built-in function 'maplist' */
  545. NODE *xmaplist(args)
  546.   NODE *args;
  547. {
  548.     return (map(args,FALSE,TRUE));
  549. }
  550.  
  551. /* map - internal mapping function */
  552. LOCAL NODE *map(args,carflag,valflag)
  553.   NODE *args; int carflag,valflag;
  554. {
  555.     NODE ***oldstk,*fcn,*lists,*arglist,*val,*p,*x,*y;
  556.     NODE *last = NIL;
  557.  
  558.     /* create a new stack frame */
  559.     oldstk = xlsave(&fcn,&lists,&arglist,&val,(NODE **)NULL);
  560.  
  561.     /* get the function to apply and the first list */
  562.     fcn = xlarg(&args);
  563.     lists = xlmatch(LIST,&args);
  564.  
  565.     /* save the first list if not saving function values */
  566.     if (!valflag)
  567.     val = lists;
  568.  
  569.     /* set up the list of argument lists */
  570.     lists = consa(lists);
  571.  
  572.     /* get the remaining argument lists */
  573.     while (args) {
  574.     lists = consd(lists);
  575.     rplaca(lists,xlmatch(LIST,&args));
  576.     }
  577.  
  578.     /* if the function is a symbol, get its value */
  579.     if (symbolp(fcn))
  580.     fcn = xleval(fcn);
  581.  
  582.     /* loop through each of the argument lists */
  583.     for (;;) {
  584.  
  585.     /* build an argument list from the sublists */
  586.     arglist = NIL;
  587.     for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
  588.         arglist = consd(arglist);
  589.         rplaca(arglist,carflag ? car(y) : y);
  590.         rplaca(x,cdr(y));
  591.     }
  592.  
  593.     /* quit if any of the lists were empty */
  594.     if (x) break;
  595.  
  596.     /* apply the function to the arguments */
  597.     if (valflag) {
  598.         p = consa(NIL);
  599.         if (val) rplacd(last,p);
  600.         else val = p;
  601.         rplaca(p,xlapply(fcn,arglist));
  602.         last = p;
  603.     }
  604.     else
  605.         xlapply(fcn,arglist);
  606.     }
  607.  
  608.     /* restore the previous stack frame */
  609.     xlstack = oldstk;
  610.  
  611.     /* return the last test expression value */
  612.     return (val);
  613. }
  614.  
  615. /* xrplca - replace the car of a list node */
  616. NODE *xrplca(args)
  617.   NODE *args;
  618. {
  619.     NODE *list,*newcar;
  620.  
  621.     /* get the list and the new car */
  622.     if ((list = xlmatch(LIST,&args)) == NIL)
  623.     xlfail("bad argument");
  624.     newcar = xlarg(&args);
  625.     xllastarg(args);
  626.  
  627.     /* replace the car */
  628.     rplaca(list,newcar);
  629.  
  630.     /* return the list node that was modified */
  631.     return (list);
  632. }
  633.  
  634. /* xrplcd - replace the cdr of a list node */
  635. NODE *xrplcd(args)
  636.   NODE *args;
  637. {
  638.     NODE *list,*newcdr;
  639.  
  640.     /* get the list and the new cdr */
  641.     if ((list = xlmatch(LIST,&args)) == NIL)
  642.     xlfail("bad argument");
  643.     newcdr = xlarg(&args);
  644.     xllastarg(args);
  645.  
  646.     /* replace the cdr */
  647.     rplacd(list,newcdr);
  648.  
  649.     /* return the list node that was modified */
  650.     return (list);
  651. }
  652.  
  653. /* xnconc - destructively append lists */
  654. NODE *xnconc(args)
  655.   NODE *args;
  656. {
  657.     NODE *list,*val;
  658.     NODE *last = NIL;
  659.  
  660.     /* concatenate each argument */
  661.     for (val = NIL; args; ) {
  662.  
  663.     /* concatenate this list */
  664.     if (list = xlmatch(LIST,&args)) {
  665.  
  666.         /* check for this being the first non-empty list */
  667.         if (val)
  668.         rplacd(last,list);
  669.         else
  670.         val = list;
  671.  
  672.         /* find the end of the list */
  673.         while (consp(cdr(list)))
  674.         list = cdr(list);
  675.  
  676.         /* save the new last element */
  677.         last = list;
  678.     }
  679.     }
  680.  
  681.     /* return the list */
  682.     return (val);
  683. }
  684.  
  685. /* xdelete - built-in function 'delete' */
  686. NODE *xdelete(args)
  687.   NODE *args;
  688. {
  689.     NODE ***oldstk,*x,*list,*fcn,*last,*val;
  690.     int tresult;
  691.  
  692.     /* create a new stack frame */
  693.     oldstk = xlsave(&x,&list,&fcn,(NODE **)NULL);
  694.  
  695.     /* get the expression to delete and the list */
  696.     x = xlarg(&args);
  697.     list = xlmatch(LIST,&args);
  698.     xltest(&fcn,&tresult,&args);
  699.     xllastarg(args);
  700.  
  701.     /* delete leading matches */
  702.     while (consp(list)) {
  703.     if (dotest(x,car(list),fcn) != tresult)
  704.         break;
  705.     list = cdr(list);
  706.     }
  707.     val = last = list;
  708.  
  709.     /* delete embedded matches */
  710.     if (consp(list)) {
  711.  
  712.     /* skip the first non-matching element */
  713.     list = cdr(list);
  714.  
  715.     /* look for embedded matches */
  716.     while (consp(list)) {
  717.  
  718.         /* check to see if this element should be deleted */
  719.         if (dotest(x,car(list),fcn) == tresult)
  720.         rplacd(last,cdr(list));
  721.         else
  722.         last = list;
  723.  
  724.         /* move to the next element */
  725.         list = cdr(list);
  726.      }
  727.     }
  728.  
  729.     /* restore the previous stack frame */
  730.     xlstack = oldstk;
  731.  
  732.     /* return the updated list */
  733.     return (val);
  734. }
  735.  
  736. /* xatom - is this an atom? */
  737. NODE *xatom(args)
  738.   NODE *args;
  739. {
  740.     NODE *arg;
  741.     arg = xlarg(&args);
  742.     xllastarg(args);
  743.     return (atom(arg) ? true : NIL);
  744. }
  745.  
  746. /* xsymbolp - is this an symbol? */
  747. NODE *xsymbolp(args)
  748.   NODE *args;
  749. {
  750.     NODE *arg;
  751.     arg = xlarg(&args);
  752.     xllastarg(args);
  753.     return (arg == NIL || symbolp(arg) ? true : NIL);
  754. }
  755.  
  756. /* xnumberp - is this a number? */
  757. NODE *xnumberp(args)
  758.   NODE *args;
  759. {
  760.     NODE *arg;
  761.     arg = xlarg(&args);
  762.     xllastarg(args);
  763.     return (fixp(arg) || floatp(arg) ? true : NIL);
  764. }
  765.  
  766. /* xboundp - is this a value bound to this symbol? */
  767. NODE *xboundp(args)
  768.   NODE *args;
  769. {
  770.     NODE *sym;
  771.     sym = xlmatch(SYM,&args);
  772.     xllastarg(args);
  773.     return (getvalue(sym) == s_unbound ? NIL : true);
  774. }
  775.  
  776. /* xnull - is this null? */
  777. NODE *xnull(args)
  778.   NODE *args;
  779. {
  780.     NODE *arg;
  781.     arg = xlarg(&args);
  782.     xllastarg(args);
  783.     return (null(arg) ? true : NIL);
  784. }
  785.  
  786. /* xlistp - is this a list? */
  787. NODE *xlistp(args)
  788.   NODE *args;
  789. {
  790.     NODE *arg;
  791.     arg = xlarg(&args);
  792.     xllastarg(args);
  793.     return (listp(arg) ? true : NIL);
  794. }
  795.  
  796. /* xconsp - is this a cons? */
  797. NODE *xconsp(args)
  798.   NODE *args;
  799. {
  800.     NODE *arg;
  801.     arg = xlarg(&args);
  802.     xllastarg(args);
  803.     return (consp(arg) ? true : NIL);
  804. }
  805.  
  806. /* xeq - are these equal? */
  807. NODE *xeq(args)
  808.   NODE *args;
  809. {
  810.     return (cequal(args,eq));
  811. }
  812.  
  813. /* xeql - are these equal? */
  814. NODE *xeql(args)
  815.   NODE *args;
  816. {
  817.     return (cequal(args,eql));
  818. }
  819.  
  820. /* xequal - are these equal? */
  821. NODE *xequal(args)
  822.   NODE *args;
  823. {
  824.     return (cequal(args,equal));
  825. }
  826.  
  827. /* cequal - common eq/eql/equal function */
  828. LOCAL NODE *cequal(args,fcn)
  829.   NODE *args; int (*fcn)();
  830. {
  831.     NODE *arg1,*arg2;
  832.  
  833.     /* get the two arguments */
  834.     arg1 = xlarg(&args);
  835.     arg2 = xlarg(&args);
  836.     xllastarg(args);
  837.  
  838.     /* compare the arguments */
  839.     return ((*fcn)(arg1,arg2) ? true : NIL);
  840. }
  841.  
  842.